home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 090 / byte1087.arc / MINIPRES.LST < prev    next >
Encoding:
File List  |  1987-07-15  |  12.1 KB  |  386 lines
  1.  
  2. /*  Program 22.1  A program for solving equations
  3.  
  4.      solve_equation(Equation,Unknown,Solution) :-
  5.     Solution is a solution to the equation Equation 
  6.     in the unknown Unknown.
  7. */
  8.     :- op(40,xfx,\).
  9.     :- op(50,xfx,^).
  10.  
  11.      solve_equation(A*B=0,X,Solution) :- 
  12.     !,
  13.         factorize(A*B,X,Factors\[]),
  14.     remove_duplicates(Factors,Factors1),
  15.     solve_factors(Factors1,X,Solution).
  16.  
  17.      solve_equation(Equation,X,Solution) :-
  18.         single_occurrence(X,Equation), 
  19.     !,
  20.         position(X,Equation,[Side|Position]),
  21.         maneuver_sides(Side,Equation,Equation1),
  22.         isolate(Position,Equation1,Solution).
  23.  
  24.      solve_equation(Lhs=Rhs,X,Solution) :-
  25.         is_polynomial(Lhs,X),
  26.     is_polynomial(Rhs,X),
  27.     !,
  28.     polynomial_normal_form(Lhs-Rhs,X,PolyForm),
  29.         solve_polynomial_equation(PolyForm,X,Solution).
  30.  
  31.      solve_equation(Equation,X,Solution) :-
  32.         offenders(Equation,X,Offenders),
  33.     multiple(Offenders),
  34.        homogenize(Equation,X,Offenders,Equation1,X1),
  35.         solve_equation(Equation1,X1,Solution1),
  36.         solve_equation(Solution1,X,Solution).
  37.  
  38. /* Program 22.1b    Supporting code for the factorization method
  39.  
  40.      factorize(Product,Term,Factors) :-
  41.       Factors is a difference-list of factors of Product  
  42.       containing Term.
  43. */
  44.  
  45.     factorize(A*B,X,Factors\Rest) :-
  46.         !,factorize(A,X,Factors\Factors1),
  47.         factorize(B,X,Factors1\Rest).
  48.      factorize(C,X,[C|Factors]\Factors) :-
  49.     subterm(X,C),  !.
  50.      factorize(C,X,Factors\Factors).
  51.  
  52. /*   solve_factors(Factors,Unknown,Solution) :-
  53.     Solution is a solution of the equation Factor=0 in
  54.     the Unknown for some Factor in the list of Factors.
  55. */
  56.  
  57.      solve_factors([Factor|Factors],X,Solution) :-
  58.     solve_equation(Factor=0,X,Solution).
  59.      solve_factors([Factor|Factors],X,Solution) :-
  60.     solve_factors(Factors,X,Solution).
  61.  
  62. /* Program 22.1c  Supporting code for the Isolation method  */
  63.  
  64.      single_occurrence(Subterm,Term) :-
  65.     occurrence(Subterm,Term,1).
  66.  
  67.      maneuver_sides(1,Lhs = Rhs,Lhs = Rhs) :- !.
  68.      maneuver_sides(2,Lhs = Rhs,Rhs = Lhs) :- !.
  69.  
  70.      isolate([N|Position],Equation,IsolatedEquation) :- 
  71.     isolax(N,Equation,Equation1), 
  72.     isolate(Position,Equation1,IsolatedEquation).
  73.      isolate([],Equation,Equation).
  74.  
  75.      /* Axioms for Isolation    */
  76.  
  77. isolax(1,-Lhs = Rhs,Lhs = -Rhs).            % Unary minus 
  78.  
  79. isolax(1,Term1+Term2 = Rhs,Term1 = Rhs-Term2).        % Addition
  80. isolax(2,Term1+Term2 = Rhs,Term2 = Rhs-Term1).         % Addition
  81.  
  82. isolax(1,Term1-Term2 = Rhs,Term1 = Rhs+Term2).        % Subtraction
  83. isolax(2,Term1-Term2 = Rhs,Term2 = Term1-Rhs).         % Subtraction
  84.  
  85. isolax(1,Term1*Term2 = Rhs,Term1 = Rhs/Term2) :-     % Multiplication 
  86.    Term2 \= 0.
  87. isolax(2,Term1*Term2 = Rhs,Term2 = Rhs/Term1) :-     % Multiplication 
  88.    Term1 \= 0.
  89.  
  90. isolax(1,Term1/Term2 = Rhs,Term1 = Rhs*Term2) :-     % Division
  91.    Term2 \= 0.
  92. isolax(2,Term1/Term2 = Rhs,Term2 = Term1/Rhs) :-     % Division
  93.    Rhs \= 0. 
  94.  
  95. isolax(1,Term1^Term2 = Rhs,Term1 = Rhs^(-Term2)).    % Exponentiation $$$ ^
  96. isolax(2,Term1^Term2 = Rhs,Term2 = log(base(Term1),Rhs)). % Exponentiation
  97.  
  98. isolax(1,sin(U) = V,U = arcsin(V)).            % Sine
  99. isolax(1,sin(U) = V,U = 180 - arcsin(V)).        % Sine
  100. isolax(1,cos(U) = V,U = arccos(V)).            % Cosine
  101. isolax(1,cos(U) = V,U = -arccos(V)).            % Cosine
  102.  
  103. /* Program 22.1d   Support code for Polynomial methods    */
  104.  
  105.     is_polynomial(X,X) :- !.
  106.     is_polynomial(Term,X) :-
  107.         constant(Term),!.
  108.     is_polynomial(Term1+Term2,X) :-
  109.         !,is_polynomial(Term1,X),
  110.         is_polynomial(Term2,X).
  111.     is_polynomial(Term1-Term2,X) :-
  112.         !,is_polynomial(Term1,X),
  113.         is_polynomial(Term2,X).
  114.     is_polynomial(Term1*Term2,X) :-
  115.         !,is_polynomial(Term1,X),
  116.         is_polynomial(Term2,X).
  117.     is_polynomial(Term1/Term2,X) :-
  118.         !,is_polynomial(Term1,X),
  119.         constant(Term2).
  120.     is_polynomial(Term^N,X) :-
  121.         !,natural_number(N),is_polynomial(Term,X).
  122.  
  123.     natural_number(N) :- integer(N),N > 0,!.
  124. /*  polynomial_normal_form(Expression,Term,PolyNormalForm) :-
  125.        PolyNormalForm  is the polynomial normal form of the 
  126.        Expression, which is a polynomial in Term.
  127. */
  128.  
  129.      polynomial_normal_form(Polynomial,X,NormalForm) :-
  130.     polynomial_form(Polynomial,X,PolyForm),
  131.     remove_zero_terms(PolyForm,NormalForm), !.
  132.  
  133.      polynomial_form(X,X,[(1,1)]).
  134.      polynomial_form(X^N,X,[(1,N)]).
  135.      polynomial_form(Term1+Term2,X,PolyForm) :-
  136.         polynomial_form(Term1,X,PolyForm1),
  137.         polynomial_form(Term2,X,PolyForm2),
  138.     add_polynomials(PolyForm1,PolyForm2,PolyForm).
  139.      polynomial_form(Term1-Term2,X,PolyForm) :-
  140.         polynomial_form(Term1,X,PolyForm1),
  141.         polynomial_form(Term2,X,PolyForm2),
  142.     subtract_polynomials(PolyForm1,PolyForm2,PolyForm).
  143.      polynomial_form(Term1*Term2,X,PolyForm) :-
  144.         polynomial_form(Term1,X,PolyForm1),
  145.         polynomial_form(Term2,X,PolyForm2),
  146.     multiply_polynomials(PolyForm1,PolyForm2,PolyForm).
  147.      polynomial_form(Term^N,X,PolyForm) :- !,
  148.     polynomial_form(Term,X,PolyForm1),
  149.     binomial(PolyForm1,N,PolyForm).
  150.      polynomial_form(Term,X,[(Term,0)]) :-
  151.     free_of(X,Term), !.
  152.  
  153.    remove_zero_terms([(0,N)|Poly],Poly1) :-
  154.     !, remove_zero_terms(Poly,Poly1).
  155.    remove_zero_terms([(C,N)|Poly],[(C,N)|Poly1]) :-
  156.     C \= 0, !, remove_zero_terms(Poly,Poly1).
  157.    remove_zero_terms([],[]).
  158.  
  159.    /*  Polynomial manipulation routines        */
  160.  
  161. /*  add_polynomials(Poly1,Poly2,Poly) :-
  162.     Poly is the sum of Poly1 and Poly2, where
  163.     Poly1, Poly2 and Poly are all in polynomial form.
  164. */
  165.  
  166.    add_polynomials([],Poly,Poly) :- !.
  167.    add_polynomials(Poly,[],Poly) :- !.
  168.    add_polynomials([(Ai,Ni)|Poly1],[(Aj,Nj)|Poly2],[(Ai,Ni)|Poly]) :-
  169.         Ni > Nj, !, add_polynomials(Poly1,[(Aj,Nj)|Poly2],Poly).
  170.    add_polynomials([(Ai,Ni)|Poly1],[(Aj,Nj)|Poly2],[(A,Ni)|Poly]) :-
  171.     Ni =:= Nj, !, A is Ai+Aj, add_polynomials(Poly1,Poly2,Poly).
  172.    add_polynomials([(Ai,Ni)|Poly1],[(Aj,Nj)|Poly2],[(Aj,Nj)|Poly]) :-
  173.     Ni < Nj, !, add_polynomials([(Ai,Ni)|Poly1],Poly2,Poly).
  174.  
  175. /*  subtract_polynomials(Poly1,Poly2,Poly) :-
  176.     Poly is the difference of Poly1 and Poly2, where
  177.     Poly1, Poly2 and Poly are all in polynomial form.
  178. */
  179.  
  180.    subtract_polynomials(Poly1,Poly2,Poly) :-
  181.     multiply_single(Poly2,(-1,0),Poly3),
  182.        add_polynomials(Poly1,Poly3,Poly), !.
  183.  
  184. /*  multiply_single(Poly1,Monomial,Poly) :-
  185.     Poly is the product of Poly1 and Monomial, where
  186.     Poly1, and Poly are in polynomial form, and Monomial 
  187.      has the form (C,N) denoting the monomial C*X^N.
  188. */
  189.  
  190.    multiply_single([(C1,N1)|Poly1],(C,N),[(C2,N2)|Poly]) :-
  191.     C2 is C1*C, N2 is N1+N, multiply_single(Poly1,(C,N),Poly).
  192.    multiply_single([],Factor,[]).
  193.  
  194. /*  multiply_polynomials(Poly1,Poly2,Poly) :-
  195.     Poly  is the product of Poly1 and Poly2, where
  196.     Poly1, Poly2 and Poly are all in polynomial form.
  197. */
  198.  
  199.    multiply_polynomials([(C,N)|Poly1],Poly2,Poly) :-
  200.     multiply_single(Poly2,(C,N),Poly3),
  201.     multiply_polynomials(Poly1,Poly2,Poly4),
  202.        add_polynomials(Poly3,Poly4,Poly).
  203.    multiply_polynomials([],P,[]).
  204.  
  205.    binomial(Poly,1,Poly).
  206.     
  207. /*   solve_polynomial_equation(Equation,Unknown,Solution) :-
  208.     Solution  is a solution to the polynomial Equation  
  209.     in the unknown Unknown.
  210. */
  211.  
  212.    solve_polynomial_equation(PolyEquation,X,X = -B/A) :-
  213.        linear(PolyEquation), !, 
  214.     pad(PolyEquation,[(A,1),(B,0)]). 
  215.    solve_polynomial_equation(PolyEquation,X,Solution) :-
  216.     quadratic(PolyEquation), !,
  217.     pad(PolyEquation,[(A,2),(B,1),(C,0)]),
  218.     discriminant(A,B,C,Discriminant),
  219.     root(X,A,B,C,Discriminant,Solution).
  220.  
  221.     discriminant(A,B,C,D) :- D is B*B - 4*A*C.
  222.  
  223.     root(X,A,B,C,0,X= -B/(2*A)).
  224.     root(X,A,B,C,D,X= (-B+sqrt(D))/(2*A)) :- D > 0.
  225.     root(X,A,B,C,D,X= (-B-sqrt(D))/(2*A)) :- D > 0.
  226.  
  227.    pad([(C,N)|Poly],[(C,N)|Poly1]) :-
  228.     !, pad(Poly,Poly1).
  229.    pad(Poly,[(0,N)|Poly1]) :-
  230.     pad(Poly,Poly1).
  231.    pad([],[]).
  232.  
  233.    linear([(Coeff,1)|Poly]).    quadratic([(Coeff,2)|Poly]).
  234.  
  235. /* Program 22.1d Supporting code for Homogenization    */
  236.  
  237.      /*  offenders(Equation,Unknown,Offenders) 
  238.     Offenders is the set of offenders of the equation in the Unknown  */
  239.  
  240.      offenders(Equation,X,Offenders) :-
  241.         parse(Equation,X,Offenders1\[]),
  242.         remove_duplicates(Offenders1,Offenders).
  243.  
  244.      /*   homogenize(
  245.                             */
  246.  
  247.      homogenize(Equation,X,Offenders,Equation1,X1) :-
  248.         reduced_term(X,Offenders,Type,X1),
  249.         rewrite(Offenders,Type,X1,Substitutions),
  250.         substitute(Equation,Substitutions,Equation1).
  251.  
  252.      reduced_term(X,Offenders,Type,X1) :-
  253.     classify(Offenders,X,Type),
  254.     candidate(Type,Offenders,X,X1).
  255.  
  256.     /*  Heuristics for exponential equations    */
  257.  
  258.     classify(Offenders,X,exponential) :-
  259.     exponential_offenders(Offenders,X).
  260.  
  261.      exponential_offenders([A^B|Offs],X) :-
  262.     free_of(X,A), subterm(X,B), exponential_offenders(Offs,X).
  263.      exponential_offenders([],X).
  264.  
  265.      candidate(exponential,Offenders,X,A^X) :-
  266.     base(Offenders,A), polynomial_exponents(Offenders,X).
  267.  
  268.      base([A^B|Offs],A) :- base(Offs,A).
  269.      base([],A).
  270.  
  271.      polynomial_exponents([A^B|Offs],X) :-
  272.     is_polynomial(B,X), polynomial_exponents(Offs,X).
  273.      polynomial_exponents([],X).
  274.  
  275.     /*   Parsing the equation and making substitutions       */
  276.  
  277.    /*  parse(Expression,Term,Offenders)
  278.     Expression is traversed to produce the set of Offenders in Term,
  279.     that is the non-algebraic subterms of Expression containing Term  */
  280.  
  281.      parse(A+B,X,L1\L2) :-
  282.     !, parse(A,X,L1\L3), parse(B,X,L3\L2).     
  283.      parse(A*B,X,L1\L2) :-
  284.     !, parse(A,X,L1\L3), parse(B,X,L3\L2).     
  285.      parse(A-B,X,L1\L2) :-
  286.     !, parse(A,X,L1\L3), parse(B,X,L3\L2).     
  287.      parse(A=B,X,L1\L2) :-
  288.     !, parse(A,X,L1\L3), parse(B,X,L3\L2).     
  289.      parse(A^B,X,L) :-
  290.     integer(B), !, parse(A,X,L).
  291.      parse(A,X,L\L) :-
  292.     free_of(X,A), !.
  293.      parse(A,X,[A|L]\L) :-
  294.     subterm(X,A), !.
  295.  
  296. /*     substitute(Equation,Substitutions,Equation1) :-
  297.     Equation1 is the result of applying the list of 
  298.     Substitutions to Equation.
  299.    */
  300.      substitute(A+B,Subs,NewA+NewB) :-
  301.     !, substitute(A,Subs,NewA), substitute(B,Subs,NewB).     
  302.      substitute(A*B,Subs,NewA*NewB) :-
  303.     !, substitute(A,Subs,NewA), substitute(B,Subs,NewB).     
  304.      substitute(A-B,Subs,NewA-NewB) :-
  305.     !, substitute(A,Subs,NewA), substitute(B,Subs,NewB).     
  306.      substitute(A=B,Subs,NewA=NewB) :-
  307.     !, substitute(A,Subs,NewA), substitute(B,Subs,NewB).     
  308.      substitute(A^B,Subs,NewA^B) :-
  309.     integer(B), !, substitute(A,Subs,NewA).
  310.      substitute(A,Subs,B) :-
  311.     member(A=B,Subs), !.
  312.      substitute(A,Subs,A).
  313.  
  314.      /*  Finding homogenization rewrite rules    */
  315.  
  316.      rewrite([Off|Offs],Type,X1,[Off=Term|Rewrites]) :-
  317.     homog_axiom(Type,Off,X1,Term),
  318.     rewrite(Offs,Type,X1,Rewrites).
  319.      rewrite([],Type,X,[]).
  320.  
  321.  
  322.      /*  Homogenization axioms    */
  323.  
  324.      homog_axiom(exponential,A^(N*X),A^X,(A^X)^N).
  325.      homog_axiom(exponential,A^(-X),A^X,1/(A^X)).
  326.      homog_axiom(exponential,A^(X+B),A^X,A^B*A^X).
  327.  
  328. /*    Utilities    */
  329.  
  330. subterm(Term,Term).
  331. subterm(Sub,Term) :-
  332.     compound(Term), functor(Term,F,N), subterm(N,Sub,Term).
  333.  
  334. subterm(N,Sub,Term) :-
  335.    arg(N,Term,Arg), subterm(Sub,Arg).
  336. subterm(N,Sub,Term) :-
  337.     N > 0,
  338.     N1 is N - 1,
  339.     subterm(N1,Sub,Term).
  340.  
  341. position(Term,Term,[]) :- !.
  342. position(Sub,Term,Path) :-
  343.         compound(Term), functor(Term,F,N), position(N,Sub,Term,Path), !.
  344.  
  345. position(N,Sub,Term,[N|Path]) :-
  346.    arg(N,Term,Arg), position(Sub,Arg,Path).
  347. position(N,Sub,Term,Path) :- 
  348.    N > 1, N1 is N-1, position(N1,Sub,Term,Path).
  349.  
  350.  
  351.      free_of(Subterm,Term) :-
  352.         occurrence(Subterm,Term,N), !, N=0.
  353.  
  354.      single_occurrence(Subterm,Term) :-      
  355.         occurrence(Subterm,Term,N), !, N=1.
  356.  
  357.   occurrence(Term,Term,1) :- !.
  358.   occurrence(Sub,Term,N) :-
  359.     compound(Term), !, functor(Term,F,M), occurrence(M,Sub,Term,0,N).
  360.   occurrence(Sub,Term,0).
  361.  
  362.   occurrence(M,Sub,Term,N1,N2) :-
  363.     M > 0, !, arg(M,Term,Arg), occurrence(Sub,Arg,N), N3 is N+N1,
  364.         M1 is M-1, occurrence(M1,Sub,Term,N3,N2).
  365.   occurrence(0,Sub,Term,N,N).
  366.  
  367.   multiple([X1,X2|Xs]).
  368.     remove_duplicates([],[]).
  369.     remove_duplicates([X|Xs],[X|Ys]) :-
  370.         remove_duplicates(Xs,Ys).
  371.     remove_duplicates([X|Xs],Ys) :-
  372.         member(X,Xs),
  373.         remove_duplicates(Xs,Ys).
  374.     compound(Term) :- functor(Term,F,N),N > 0,!.
  375.  
  376. %  Program 22.2     /* Testing and data    */
  377. test_press(X,Y) :- equation(X,E,U), solve_equation(E,U,Y).
  378.  
  379. equation(1,x^2-3*x+2=0,x).
  380.  
  381. equation(2,cos(x)*(1-2*sin(x))=0,x).
  382.  
  383. equation(3,2^(2*x) - 5*2^(x+1) + 16 = 0,x).
  384.  
  385.  
  386.